#lang racket/base
(provide
 prop:infix-transformer
 infix-transformer?
 infix-transformer-binding?
 identifier-fixity
 rewrite-infix->prefix)

(require
 syntax/parse
 (only-in syntax/parse [attribute @]))

(define-values [prop:infix-transformer
                infix-transformer?
                infix-transformer-ref]
  (make-struct-type-property 'infix-transformer))

(define (fixity? x)
  (case x
    [(#f left right) #t]
    [else #f]))

;; id -> fixity
;; NOTE: does not fail on non-infix bindings, instead
;;       returns #f
(define (identifier-fixity id #:ctx [idctx '()])
  (define val
    (syntax-local-value id (λ () #f) idctx))
  (and (infix-transformer? val)
       ((infix-transformer-ref val) val id)))

;; id -> boolean
(define (infix-transformer-binding? id #:ctx [idctx '()])
  (infix-transformer?
   (syntax-local-value id (λ () #f) idctx)))

;; #'(term ...) -> stx
(define (rewrite-infix->prefix
         terms
         #:src [src (if (pair? terms) (car terms) terms)]
         #:ctx [idctx '()])
  (syntax-parse terms
    [(t) (syntax/loc src t)]
    [(t0 op t1) (syntax/loc src (op t0 t1))]
    [(t0 op0 t1 {~seq op t} ...)
     (define (rw combine terms ops)
       (foldl combine (car terms) ops (cdr terms)))

     (for ([op (in-list (@ op))])
       (unless (free-identifier=? op #'op0)
         (raise-syntax-error #f
           "mixing infix operators unsupported" op)))

     (case (identifier-fixity #'op0)
       [(left)
        (rw (λ (op rhs lhs) (quasisyntax/loc src (#,op #,lhs #,rhs)))
            (list* #'t0 #'t1 (@ t))
            (list* #'op0 (@ op)))]
       [(right)
        (rw (λ (op lhs rhs) (quasisyntax/loc src (#,op #,lhs #,rhs)))
            (reverse (list* #'t0 #'t1 (@ t)))
            (reverse (list* #'op0 (@ op))))]
       [else
        (raise-syntax-error #f
          "cannot chain operator with unspecified fixity" #'op0)])]))
